home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / ccc.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  10KB  |  435 lines
  1. /* ******************************************************************** */
  2. /* ccc.c             Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Comparing, copying and conversion.                                   */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: ccc.c,v 1.9 1992/05/19 11:15:24 pab Exp $
  9.  *
  10.  * $Log: ccc.c,v $
  11.  * Revision 1.9  1992/05/19  11:15:24  pab
  12.  * fixed equal
  13.  *
  14.  * Revision 1.8  1992/02/27  15:49:10  pab
  15.  * lose type_condition
  16.  *
  17.  * Revision 1.7  1992/01/21  22:38:31  pab
  18.  * Fixed equal on structs
  19.  *
  20.  * Revision 1.6  1992/01/17  22:25:49  pab
  21.  * Added conversion+copy methods
  22.  *
  23.  * Revision 1.5  1992/01/09  22:28:44  pab
  24.  * Fixed for low tag ints
  25.  *
  26.  * Revision 1.4  1991/12/22  15:13:53  pab
  27.  * Xmas revision
  28.  *
  29.  * Revision 1.3  1991/11/15  13:44:25  pab
  30.  * copyalloc rev 0.01
  31.  *
  32.  * Revision 1.2  1991/09/11  12:07:03  pab
  33.  * 11/9/91 First Alpha release of modified system
  34.  *
  35.  * Revision 1.1  1991/08/12  16:49:29  pab
  36.  * Initial revision
  37.  *
  38.  * Revision 1.4  1991/02/14  10:07:28  kjp
  39.  * Added an eq lisp function handle for table optimisation.
  40.  *
  41.  * Revision 1.3  1991/02/14  05:59:24  kjp
  42.  * Fixed Fn_equal in the symbol case.
  43.  *
  44.  */
  45.  
  46. /*
  47.  * Change Log:
  48.  *   Version 1, March 1990 (Compiler rationalisation)
  49.  */
  50.  
  51. #include <stdio.h>
  52. #include <string.h>
  53. #include "funcalls.h"
  54. #include "defs.h"
  55. #include "structs.h"
  56.  
  57. #include "error.h"
  58. #include "global.h"
  59.  
  60. #include "calls.h"
  61. #include "modboot.h"
  62. #include "ngenerics.h"
  63.  
  64. LispObject function_eq;
  65.  
  66. EUFUN_2( Fn_eq, x, y)
  67. {
  68.   if (x == y) 
  69.     return(lisptrue);
  70.   else
  71.     return(nil);
  72. }
  73. EUFUN_CLOSE
  74.  
  75. /* Non-generic, hacked equal */
  76.  
  77. LispObject equal_lookup_table;
  78.  
  79. EUFUN_2( Fn_equal, x, y)
  80. {
  81.   while (TRUE) {
  82.     if (x == y) return lisptrue;
  83.     if (typeof(x) != typeof(y)) return nil;
  84.     switch (typeof(x)) {
  85.     case TYPE_CONS:
  86.       if (EUCALL_2(Fn_equal, CAR(x), CAR(y))) {
  87.     ARG_0(stackbase) = x = CDR(ARG_0(stackbase));
  88.     ARG_1(stackbase) = y = CDR(ARG_1(stackbase));
  89.     continue;
  90.       }
  91.       else return nil;
  92.     case TYPE_CHAR:
  93.       if ((((x->CHAR).code) == ((y->CHAR).code)) &&
  94.       (((x->CHAR).font) == ((y->CHAR).font))) return lisptrue;
  95.       else return nil;
  96.     case TYPE_STRING:
  97.       if (strcmp(stringof(x),stringof(y)) == 0) return lisptrue;
  98.       else return nil;
  99.     case TYPE_SYMBOL:
  100.       return nil;
  101.     case TYPE_TABLE:
  102.     case TYPE_THREAD:
  103.     case TYPE_STREAM:
  104.       CallError(stacktop,"Unimplemented facility in equal",nil,NONCONTINUABLE);
  105.     case TYPE_INT:
  106.       if (intval(x) == intval(y)) return lisptrue;
  107.       else return nil;
  108.     case TYPE_FLOAT:
  109.       if ((x->FLOAT).fvalue == (y->FLOAT).fvalue) return lisptrue;
  110.       else return nil;
  111.     case TYPE_RATIONAL:
  112.       if (EUCALL_2(Fn_equal,(x->RATIO).numerator,(y->RATIO).numerator)) {
  113.     x = ARG_0(stackbase); y = ARG_1(stackbase);
  114.     if (EUCALL_2(Fn_equal,(x->RATIO).denominator,(y->RATIO).denominator))
  115.       return lisptrue;
  116.     else return nil;
  117.       }
  118.       else return nil;
  119.     case TYPE_COMPLEX:
  120.       if (EUCALL_2(Fn_equal,(x->COMPLEX).real,(y->COMPLEX).real)) {
  121.     x = ARG_0(stackbase); y = ARG_1(stackbase);
  122.     if (EUCALL_2(Fn_equal,(x->COMPLEX).imaginary,(y->COMPLEX).imaginary))
  123.       return lisptrue;
  124.     else return nil;
  125.       }
  126.       else return nil;
  127.     default:
  128.       {
  129.     LispObject foo = allocate_integer(stacktop,(int) typeof(x));
  130.     LispObject ans;
  131.     EUCALLSET_2(ans, Fn_tref, equal_lookup_table, foo);
  132.     x = ARG_0(stackbase); y = ARG_1(stackbase);
  133.     if (null(ans))
  134.       (void) CallError(stacktop,
  135.                "equal: No method for ~a", x, NONCONTINUABLE);
  136.     return EUCALL_3(apply2,ans,x,y);
  137.       }
  138.     }
  139.   }
  140.  
  141.   return(nil); /* dummy */
  142.  
  143. }
  144. EUFUN_CLOSE
  145.  
  146. /* Non-generic hacked copy */
  147.  
  148. EUFUN_1( Fn_copy, form)
  149. {
  150.   switch (typeof(form)) 
  151.     {
  152.     case TYPE_NULL:
  153.       return(nil);
  154.     case TYPE_INT:
  155.       return allocate_integer(stacktop,intval(form));
  156.     case TYPE_SYMBOL:
  157.       return form;
  158.     case TYPE_TABLE:
  159.       return EUCALL_1(table_copy,form);
  160.     case TYPE_CONS:
  161.       {
  162.     LispObject xx, yy;
  163.     EUCALLSET_1(xx, Fn_copy, CAR(form));
  164.     EUCALLSET_1(yy, Fn_copy, CDR(ARG_0(stackbase)));
  165.     return EUCALL_2(Fn_cons,xx, yy);
  166.       }
  167.     default:
  168.       (void) CallError(stacktop,
  169.                "copy: No method for ~a", form, NONCONTINUABLE);
  170.     }
  171.  
  172.   return(nil); /* dummy */
  173.  
  174. }
  175. EUFUN_CLOSE
  176.  
  177. /* ******************************************************************** */
  178. /*                          Generic Copying                             */
  179. /* ******************************************************************** */
  180.  
  181. static LispObject generic_copy;
  182.  
  183. EUFUN_1( Gf_copy, obj)
  184. {
  185.   return(generic_apply_1(stacktop,generic_copy,obj));
  186. }
  187. EUFUN_CLOSE
  188.  
  189. EUFUN_1( Md_copy_Object, obj)
  190. {
  191.   return(Fn_copy(stackbase));
  192. }
  193. EUFUN_CLOSE
  194.  
  195. #ifndef NO_COMPACT
  196. #define myvref(v,i) vref(v,i)
  197. #else
  198. #define vrefupdate(v,i,obj) (*(&(v->VECTOR.base)+i)=obj)
  199. #define myvref(v,i) (*(&(v->VECTOR.base)+i))
  200. #endif
  201.  
  202. EUFUN_1( Md_copy_Pair, p)
  203. {
  204.   LispObject new;
  205.  
  206.   if (p == nil) return(nil);
  207.   
  208.   new = (is_cons(CDR(p)) ? EUCALL_1(Gf_copy,CDR(p)) : CDR(p));
  209.   p = ARG_0(stackbase);
  210.   return EUCALL_2( Fn_cons, CAR(p), new);
  211. }
  212. EUFUN_CLOSE
  213.  
  214. EUFUN_1( Md_copy_Vector, v)
  215. {
  216.   LispObject new;
  217.   int i;
  218.  
  219.   new = (LispObject) allocate_vector(stacktop,v->VECTOR.length);
  220.   v = ARG_0(stackbase);
  221.   for (i=0; i<v->VECTOR.length; ++i) {
  222.     vrefupdate(new,i,myvref(v,i));
  223.   }
  224.  
  225.   return(new);
  226. }
  227. EUFUN_CLOSE
  228.  
  229. EUFUN_1( Md_copy_Structure, str)
  230. {
  231.   LispObject new;
  232.  
  233.  
  234. #ifdef dunno /* Tue Jul 23 12:06:58 1991 */
  235. /**/  STACK(str);
  236. /**/  if (typeof(str) != TYPE_INSTANCE) return(Fn_copy(/*+:NULL:+*/str));
  237. /**/  new = allocate_instance(classof(str));
  238. /**/  STACK(new);
  239. /**/  new->INSTANCE.slots = Gf_copy(str->INSTANCE.slots);
  240. /**/  UNSTACK(2);
  241. #endif /* dunno Tue Jul 23 12:06:58 1991 */
  242.   
  243.   return(str);
  244. }
  245. EUFUN_CLOSE
  246.  
  247. /* ******************************************************************** */
  248. /*                          Generic Equality                            */
  249. /* ******************************************************************** */
  250.  
  251. LispObject generic_equal;
  252.  
  253. EUFUN_2( Gf_equal, o1, o2)
  254. {
  255.   return(generic_apply_2(stacktop,generic_equal,o1,o2));
  256. }
  257. EUFUN_CLOSE
  258.  
  259. /* Basic methods... */
  260.  
  261. EUFUN_2( Md_equal_Object_Object, o1, o2)
  262. {
  263.   /* Same class? */
  264.  
  265.   if (classof(o1) != classof(o2)) return(nil);
  266.  
  267.   /* Same type? */
  268.  
  269.   if (typeof(o1) != typeof(o2)) return(nil);
  270.  
  271.   /* Instance? */
  272.  
  273. /**
  274.   if (typeof(o1) == TYPE_INSTANCE) {
  275.     if (Gf_equal(o1->INSTANCE.slots,o2->INSTANCE.slots) == nil) {
  276.       UNSTACK(2);
  277.       return(nil);
  278.     }
  279.     else {
  280.       UNSTACK(2);
  281.       return(lisptrue);
  282.     }
  283.   }
  284.   **/
  285.  
  286.   return(Fn_equal(stackbase));
  287. }
  288. EUFUN_CLOSE
  289.  
  290. EUFUN_2( Md_equal_Pair_Pair, p1, p2)
  291. {
  292.   LispObject xx;
  293.   if (p1 == p2) return(lisptrue);
  294.   if (p1 == nil) return(nil);
  295.   if (p2 == nil) return(nil);
  296.  
  297.   if (EUCALL_2(Gf_equal,CAR(p1),CAR(p2)) == nil)
  298.     return nil;
  299.   p1 = ARG_0(stackbase); p2 = ARG_1(stackbase);
  300.   if (EUCALL_2(Gf_equal,CDR(p1),CDR(p2)) == nil)
  301.     return(nil);
  302.   else
  303.     return(lisptrue);
  304. }
  305. EUFUN_CLOSE
  306.  
  307. EUFUN_2( Md_equal_Vector_Vector, v1, v2)
  308. {
  309.   int i;
  310.  
  311.   if (v1->VECTOR.length != v2->VECTOR.length) return(nil);
  312.  
  313.   for (i=0; i<v1->VECTOR.length; ++i) {
  314.     if (EUCALL_2(Gf_equal,myvref(v1,i),myvref(v2,i)) == nil) return(nil);
  315.     v1 = ARG_0(stackbase); v2 = ARG_1(stackbase);
  316.   }
  317.   
  318.   return(lisptrue);
  319. }
  320. EUFUN_CLOSE
  321.  
  322. EUFUN_2( Md_equal_Structure_Structure, s1, s2)
  323. {
  324.   int i;
  325.   LispObject res;
  326.  
  327.   if (EUCALL_2(Gf_equal,classof(s1),classof(s2)) == nil) 
  328.     return  nil;
  329.   
  330.   for (i=0; i<classof(s1)->CLASS.local_count ; i++)
  331.     {
  332.       if (slotref(s1,i)!=slotref(s2,i))
  333.     return nil;
  334.       i++;
  335.     }
  336.  
  337.   return lisptrue;
  338.   
  339. }
  340. EUFUN_CLOSE
  341.  
  342. EUFUN_2( Md_equal_Class_Class, c1, c2)
  343. {
  344.   return((c1 == c2 ? lisptrue : nil));
  345. }
  346. EUFUN_CLOSE
  347.  
  348.  
  349. /* ******************************************************************** */
  350. /*                          Generic Conversion                          */
  351. /* ******************************************************************** */
  352.  
  353. EUFUN_1( Md_generic_convert_Pair_Vector, l1)
  354. {
  355.   LispObject walker;
  356.   LispObject new;
  357.   int i;
  358.  
  359.   if (l1 == nil) return(nil);
  360.   new = (LispObject)
  361.           allocate_vector(stacktop,intval(EUCALL_1(Fn_length,l1)));
  362.  
  363.   l1 = ARG_0(stackbase);
  364.   for (i=0,walker = l1; is_cons(walker); ++i,walker = CDR(walker)) 
  365.     vrefupdate(new,i,CAR(walker));
  366.  
  367.   return(new);
  368. }
  369. EUFUN_CLOSE
  370.  
  371. EUFUN_1( Md_generic_convert_Vector_Pair, v1)
  372. {
  373.   extern LispObject Fn_convert_vector_list(LispObject*);
  374.   
  375.   return(Fn_convert_vector_list(stackbase));
  376. }
  377. EUFUN_CLOSE
  378.  
  379. #define CCC_ENTRIES 14
  380. MODULE Module_ccc;
  381. LispObject Module_ccc_values[CCC_ENTRIES];
  382.  
  383. void initialise_ccc(LispObject *stacktop)
  384. {
  385.   extern LispObject Basic_Structure;
  386.  
  387.   open_module(stacktop,
  388.           &Module_ccc,
  389.           Module_ccc_values,
  390.           "ccc",
  391.           CCC_ENTRIES);
  392.  
  393.   function_eq = make_module_function(stacktop,"eq",Fn_eq,2);
  394.   add_root(&function_eq);
  395.  
  396.   EUCALLSET_1(equal_lookup_table, Fn_make_table,nil);
  397.   add_root(&equal_lookup_table);
  398.   generic_equal = make_wrapped_module_generic(stacktop,"equal",2,Gf_equal);
  399.   add_root(&generic_equal);
  400.   (void) make_module_function(stacktop,"generic_equal,Cons,Cons",
  401.                   Md_equal_Pair_Pair,2
  402.                   );
  403.   (void) make_module_function(stacktop,"generic_equal,Object,Object",
  404.                   Md_equal_Object_Object,2
  405.                   );
  406.   (void) make_module_function(stacktop,"generic_equal,Vector,Vector",
  407.                   Md_equal_Vector_Vector,2
  408.                   );
  409.   (void) make_module_function(stacktop,"generic_equal,Basic_Structure,Basic_Structure",
  410.                   Md_equal_Structure_Structure,2
  411.                   );
  412.   (void) make_module_function(stacktop,"generic_equal,Standard_Class,Standard_Class",
  413.                   Md_equal_Class_Class,2
  414.                   );
  415.  
  416.   generic_copy = make_wrapped_module_generic(stacktop,"copy",1,Gf_copy);
  417.   add_root(&generic_copy);
  418.   (void) make_module_function(stacktop,"generic_copy,Object",Md_copy_Object,1);
  419.   (void) make_module_function(stacktop,"generic_copy,Cons",Md_copy_Pair,1);
  420.   (void) make_module_function(stacktop,"generic_copy,Vector",Md_copy_Vector,1);
  421.   (void) make_module_function(stacktop,
  422.                   "generic_copy,Basic_Structure",Md_copy_Structure,1);
  423.  
  424.   /* conversion methods */
  425.   (void) make_module_function(stacktop,"generic_generic_convert,Cons,Vector",
  426.                   Md_generic_convert_Pair_Vector,1
  427.                   );
  428.   (void) make_module_function(stacktop,"generic_generic_convert,Vector,Cons",
  429.                   Md_generic_convert_Vector_Pair,1
  430.                   );
  431.  
  432.   close_module();
  433. }
  434.  
  435.